*+--------------------------------------------------------------------
*+
*+
*+
*+    Source Module => /home/paul/click/qsort.prg
*+
*+
*+
*+    Click! is a Clipper/Xbase++ source code reformatter.
*+
*+    
*+
*+    Note:Phil is no longer actively developing Click!.
*+
*+    Copyright(C) 1996-1999 by Phil Barnett.
*+
*+       
*+
*+    This program is free software; you can redistribute it and/or modify it
*+
*+    under the terms of the GNU General Public License as published by the
*+
*+    Free Software Foundation; either version 2 of the License, or (at your
*+
*+    option) any later version.
*+
*+    
*+
*+    This program is distributed in the hope that it will be useful, but
*+
*+    WITHOUT ANY WARRANTY; without even the implied warranty of
*+
*+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
*+
*+    General Public License for more details.
*+
*+    
*+
*+    You should have received a copy of the GNU General Public License along
*+
*+    with this program; if not, contact the Free Software Foundation, Inc.,
*+
*+    51 Franklin St, Fifth Floor Boston, MA 02110, USA, or www.fsf.org.
*+
*+    
*+
*+    You can contact me at:
*+
*+    
*+
*+    Phil Barnett
*+
*+    Box 944
*+
*+    Plymouth, Florida  32768
*+
*+    
*+
*+    or
*+
*+    
*+
*+    philb@iag.net
*+
*+    
*+
*+    
*+
*+    Ported to Linux and xHarbour compiler, minor feature additions.
*+
*+    Changed version to 3.00xHarbour  Changes
*+
*+    GPL version 3 Copyright (C) 2006-9 by Paul States 
*+
*+    Contact:broadcastmail AT NOSPAM 123mail.org.
*+
*+
*+
*+    Functions: Function QuickSort()
*+               Procedure bSort()
*+               Procedure qSort()
*+
*+    Reformatted by Click! 3.00Harbour on Apr-13-2009 at  2:30 pm
*+
*+
*+--------------------------------------------------------------------
*+



/*
 #: 150 S0/CompuServe Mail
    28-Nov-93 14:46 EST
Sb: Is there a fast ASORT()
Fm: Trevor Dunsford [72074,1263]

Raymond,

The quickSort function just sets up the call to the bsort/qsort
functions. bsort() will handle evaluation of codeblocks and qsort() is
optimized to handle one dimensional arrays.  The codeblock for bsort is
slightly different than asort, instead of the usual { |x,y| x[1]<y[1] },
it is just { |x| x[1] } because of the way it handles comparison.  I
believe, that with a few simple modifications, you could make bsort use
the asort codeblocks...

trev
*/

#include "common.ch"

//
// QuickSort(<aList>,[<bBlock>]) --> aList
//   * <bBlock> format is { |<var>| <var>[<offset>] }
//



*+--------------------------------------------------------------------
*+
*+
*+
*+    Function QuickSort()
*+
*+    Called from ( cmd_list.prg )   3 - function init_list()
*+
*+       Calls    ( qsort.prg    )   1 - procedure bsort()
*+                ( unresolved   )   1 - function isblock()
*+                ( qsort.prg    )   1 - procedure qsort()
*+
*+
*+
*+--------------------------------------------------------------------
*+
*+
*+
function QuickSort(aList,bBlock)



if len(aList) > 0
   if isblock(bBlock)
      bsort(@aList,1,len(aList),@bBlock)
   else
      qsort(@aList,1,len(aList))
   endif
endif

return aList



*+--------------------------------------------------------------------
*+
*+
*+
*+    Procedure bSort()
*+
*+    Called from ( qsort.prg    )   1 - function quicksort()
*+                                   2 - procedure bsort()
*+
*+       Calls    ( qsort.prg    )   2 - procedure bsort()
*+
*+
*+
*+--------------------------------------------------------------------
*+
*+
*+
procedure bSort(a,l,r,b)



local y
local i := l
local j := r
local x := eval(b,a[int((l+r) / 2)])

while eval(b,a[i]) < x
   i ++
end

while x < eval(b,a[j])
   j --
end

if i <= j
   y      := a[i]
   a[ i ] := a[j]
   a[ j ] := y
   i ++
   j --
endif

do while i < j

   while eval(b,a[i]) < x
      i ++
   end

   while x < eval(b,a[j])
      j --
   end

   if i <= j
      y      := a[i]
      a[ i ] := a[j]
      a[ j ] := y
      i ++
      j --
   endif

enddo

if l < j
   bSort(@a,l,j,@b)
endif

if i < r
   bSort(@a,i,r,@b)
endif

return



*+--------------------------------------------------------------------
*+
*+
*+
*+    Procedure qSort()
*+
*+    Called from ( qsort.prg    )   1 - function quicksort()
*+                                   2 - procedure qsort()
*+
*+       Calls    ( qsort.prg    )   2 - procedure qsort()
*+
*+
*+
*+--------------------------------------------------------------------
*+
*+
*+
procedure qSort(a,l,r)



local y
local i := l
local j := r
local x := a[int((l+r) / 2)]

while a[i] < x
   i ++
end

while x < a[j]
   j --
end

if i <= j
   y      := a[i]
   a[ i ] := a[j]
   a[ j ] := y
   i ++
   j --
endif

do while i < j

   while a[i] < x
      i ++
   end

   while x < a[j]
      j --
   end

   if i <= j
      y      := a[i]
      a[ i ] := a[j]
      a[ j ] := y
      i ++
      j --
   endif

enddo

if l < j
   qSort(@a,l,j)
endif

if i < r
   qSort(@a,i,r)
endif

return



*+ EOF: qsort.prg
*+
